home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / harvest.cpt / Harvest C / Tcl 6.2 / tclProc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-04-12  |  14.5 KB  |  576 lines
  1. /* 
  2.  * tclProc.c --
  3.  *
  4.  *    This file contains routines that implement Tcl procedures,
  5.  *    including the "proc" and "uplevel" commands.
  6.  *
  7.  * Copyright 1987-1991 Regents of the University of California
  8.  * Permission to use, copy, modify, and distribute this
  9.  * software and its documentation for any purpose and without
  10.  * fee is hereby granted, provided that the above copyright
  11.  * notice appear in all copies.  The University of California
  12.  * makes no representations about the suitability of this
  13.  * software for any purpose.  It is provided "as is" without
  14.  * express or implied warranty.
  15.  */
  16.  
  17. #ifndef lint
  18. static char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclProc.c,v 1.59 91/09/30 16:59:54 ouster Exp $ SPRITE (Berkeley)";
  19. #endif
  20.  
  21. #include "tclInt.h"
  22.  
  23. #ifdef macintosh
  24. #    pragma segment tclProc
  25. #endif
  26.  
  27. /*
  28.  * Forward references to procedures defined later in this file:
  29.  */
  30.  
  31. static  int    InterpProc _ANSI_ARGS_((ClientData clientData,
  32.             Tcl_Interp *interp, int argc, char **argv));
  33. static  void    ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
  34.  
  35. /*
  36.  *----------------------------------------------------------------------
  37.  *
  38.  * Tcl_ProcCmd --
  39.  *
  40.  *    This procedure is invoked to process the "proc" Tcl command.
  41.  *    See the user documentation for details on what it does.
  42.  *
  43.  * Results:
  44.  *    A standard Tcl result value.
  45.  *
  46.  * Side effects:
  47.  *    A _new procedure gets created.
  48.  *
  49.  *----------------------------------------------------------------------
  50.  */
  51.  
  52.     /* ARGSUSED */
  53. int
  54. Tcl_ProcCmd(dummy, interp, argc, argv)
  55.     ClientData dummy;            /* Not used. */
  56.     Tcl_Interp *interp;            /* Current interpreter. */
  57.     int argc;                /* Number of arguments. */
  58.     char **argv;            /* Argument strings. */
  59. {
  60.     register Interp *iPtr = (Interp *) interp;
  61.     register Proc *procPtr;
  62.     int result, argCount, i;
  63.     char **argArray = NULL;
  64.     Arg *lastArgPtr;
  65.     register Arg *argPtr = NULL;    /* Initialization not needed, but
  66.                      * prevents compiler warning. */
  67.  
  68.     if (argc != 4) {
  69.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  70.         " name args body\"", (char *) NULL);
  71.     return TCL_ERROR;
  72.     }
  73.  
  74.     procPtr = (Proc *) ckalloc(sizeof(Proc));
  75.     procPtr->iPtr = iPtr;
  76.     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
  77.     strcpy(procPtr->command, argv[3]);
  78.     procPtr->argPtr = NULL;
  79.  
  80.     /*
  81.      * Break up the argument list into argument specifiers, then process
  82.      * each argument specifier.
  83.      */
  84.  
  85.     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
  86.     if (result != TCL_OK) {
  87.     goto procError;
  88.     }
  89.     lastArgPtr = NULL;
  90.     for (i = 0; i < argCount; i++) {
  91.     int fieldCount, nameLength, valueLength;
  92.     char **fieldValues;
  93.  
  94.     /*
  95.      * Now divide the specifier up into name and default.
  96.      */
  97.  
  98.     result = Tcl_SplitList(interp, argArray[i], &fieldCount,
  99.         &fieldValues);
  100.     if (result != TCL_OK) {
  101.         goto procError;
  102.     }
  103.     if (fieldCount > 2) {
  104.         ckfree((char *) fieldValues);
  105.         Tcl_AppendResult(interp,
  106.             "too many fields in argument specifier \"",
  107.             argArray[i], "\"", (char *) NULL);
  108.         result = TCL_ERROR;
  109.         goto procError;
  110.     }
  111.     if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
  112.         ckfree((char *) fieldValues);
  113.         Tcl_AppendResult(interp, "procedure \"", argv[1],
  114.             "\" has argument with no name", (char *) NULL);
  115.         result = TCL_ERROR;
  116.         goto procError;
  117.     }
  118.     nameLength = strlen(fieldValues[0]) + 1;
  119.     if (fieldCount == 2) {
  120.         valueLength = strlen(fieldValues[1]) + 1;
  121.     } else {
  122.         valueLength = 0;
  123.     }
  124.     argPtr = (Arg *) ckalloc((unsigned)
  125.         (sizeof(Arg) - sizeof(argPtr->name) + nameLength
  126.         + valueLength));
  127.     if (lastArgPtr == NULL) {
  128.         procPtr->argPtr = argPtr;
  129.     } else {
  130.         lastArgPtr->nextPtr = argPtr;
  131.     }
  132.     lastArgPtr = argPtr;
  133.     argPtr->nextPtr = NULL;
  134.     strcpy(argPtr->name, fieldValues[0]);
  135.     if (fieldCount == 2) {
  136.         argPtr->defValue = argPtr->name + nameLength;
  137.         strcpy(argPtr->defValue, fieldValues[1]);
  138.     } else {
  139.         argPtr->defValue = NULL;
  140.     }
  141.     ckfree((char *) fieldValues);
  142.     }
  143.  
  144.     Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
  145.         ProcDeleteProc);
  146.     ckfree((char *) argArray);
  147.     return TCL_OK;
  148.  
  149.     procError:
  150.     ckfree(procPtr->command);
  151.     while (procPtr->argPtr != NULL) {
  152.     argPtr = procPtr->argPtr;
  153.     procPtr->argPtr = argPtr->nextPtr;
  154.     ckfree((char *) argPtr);
  155.     }
  156.     ckfree((char *) procPtr);
  157.     if (argArray != NULL) {
  158.     ckfree((char *) argArray);
  159.     }
  160.     return result;
  161. }
  162.  
  163. /*
  164.  *----------------------------------------------------------------------
  165.  *
  166.  * TclGetFrame --
  167.  *
  168.  *    Given a description of a procedure frame, such as the first
  169.  *    argument to an "uplevel" or "upvar" command, locate the
  170.  *    call frame for the appropriate level of procedure.
  171.  *
  172.  * Results:
  173.  *    The return value is -1 if an error occurred in finding the
  174.  *    frame (in this case an error message is left in interp->result).
  175.  *    1 is returned if string was either a number or a number preceded
  176.  *    by "#" and it specified a valid frame.  0 is returned if string
  177.  *    isn't one of the two things above (in this case, the lookup
  178.  *    acts as if string were "1").  The variable pointed to by
  179.  *    framePtrPtr is filled in with the address of the desired frame
  180.  *    (unless an error occurs, in which case it isn't modified).
  181.  *
  182.  * Side effects:
  183.  *    None.
  184.  *
  185.  *----------------------------------------------------------------------
  186.  */
  187.  
  188. int
  189. TclGetFrame(interp, string, framePtrPtr)
  190.     Tcl_Interp *interp;        /* Interpreter in which to find frame. */
  191.     char *string;        /* String describing frame. */
  192.     CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
  193.                  * if global frame indicated). */
  194. {
  195.     register Interp *iPtr = (Interp *) interp;
  196.     int level, result;
  197.     CallFrame *framePtr;
  198.  
  199.     if (iPtr->varFramePtr == NULL) {
  200.     iPtr->result = "already at top level";
  201.     return -1;
  202.     }
  203.  
  204.     /*
  205.      * Parse string to figure out which level number to go to.
  206.      */
  207.  
  208.     result = 1;
  209.     if (*string == '#') {
  210.     if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
  211.         return -1;
  212.     }
  213.     if (level < 0) {
  214.         levelError:
  215.         Tcl_AppendResult(interp, "bad level \"", string, "\"",
  216.             (char *) NULL);
  217.         return -1;
  218.     }
  219.     } else if (isdigit(*string)) {
  220.     if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
  221.         return -1;
  222.     }
  223.     level = iPtr->varFramePtr->level - level;
  224.     } else {
  225.     level = iPtr->varFramePtr->level - 1;
  226.     result = 0;
  227.     }
  228.  
  229.     /*
  230.      * Figure out which frame to use, and modify the interpreter so
  231.      * its variables come from that frame.
  232.      */
  233.  
  234.     if (level == 0) {
  235.     framePtr = NULL;
  236.     } else {
  237.     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  238.         framePtr = framePtr->callerVarPtr) {
  239.         if (framePtr->level == level) {
  240.         break;
  241.         }
  242.     }
  243.     if (framePtr == NULL) {
  244.         goto levelError;
  245.     }
  246.     }
  247.     *framePtrPtr = framePtr;
  248.     return result;
  249. }
  250.  
  251. #ifdef macintosh
  252. #    pragma segment tclProc2
  253. #endif
  254.  
  255. /*
  256.  *----------------------------------------------------------------------
  257.  *
  258.  * Tcl_UplevelCmd --
  259.  *
  260.  *    This procedure is invoked to process the "uplevel" Tcl command.
  261.  *    See the user documentation for details on what it does.
  262.  *
  263.  * Results:
  264.  *    A standard Tcl result value.
  265.  *
  266.  * Side effects:
  267.  *    See the user documentation.
  268.  *
  269.  *----------------------------------------------------------------------
  270.  */
  271.  
  272.     /* ARGSUSED */
  273. int
  274. Tcl_UplevelCmd(dummy, interp, argc, argv)
  275.     ClientData dummy;            /* Not used. */
  276.     Tcl_Interp *interp;            /* Current interpreter. */
  277.     int argc;                /* Number of arguments. */
  278.     char **argv;            /* Argument strings. */
  279. {
  280.     register Interp *iPtr = (Interp *) interp;
  281.     int result;
  282.     CallFrame *savedVarFramePtr, *framePtr;
  283.  
  284.     if (argc < 2) {
  285.     uplevelSyntax:
  286.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  287.         " ?level? command ?command ...?\"", (char *) NULL);
  288.     return TCL_ERROR;
  289.     }
  290.  
  291.     /*
  292.      * Find the level to use for executing the command.
  293.      */
  294.  
  295.     result = TclGetFrame(interp, argv[1], &framePtr);
  296.     if (result == -1) {
  297.     return TCL_ERROR;
  298.     }
  299.     argc -= (result+1);
  300.     argv += (result+1);
  301.  
  302.     /*
  303.      * Modify the interpreter state to execute in the given frame.
  304.      */
  305.  
  306.     savedVarFramePtr = iPtr->varFramePtr;
  307.     iPtr->varFramePtr = framePtr;
  308.  
  309.     /*
  310.      * Execute the residual arguments as a command.
  311.      */
  312.  
  313.     if (argc == 0) {
  314.     goto uplevelSyntax;
  315.     }
  316.     if (argc == 1) {
  317.     result = Tcl_Eval(interp, argv[0], 0, (char **) NULL);
  318.     } else {
  319.     char *cmd;
  320.  
  321.     cmd = Tcl_Concat(argc, argv);
  322.     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  323.     ckfree(cmd);
  324.     }
  325.     if (result == TCL_ERROR) {
  326.     char msg[60];
  327.     sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
  328.     Tcl_AddErrorInfo(interp, msg);
  329.     }
  330.  
  331.     /*
  332.      * Restore the variable frame, and return.
  333.      */
  334.  
  335.     iPtr->varFramePtr = savedVarFramePtr;
  336.     return result;
  337. }
  338.  
  339. /*
  340.  *----------------------------------------------------------------------
  341.  *
  342.  * TclFindProc --
  343.  *
  344.  *    Given the name of a procedure, return a pointer to the
  345.  *    record describing the procedure.
  346.  *
  347.  * Results:
  348.  *    NULL is returned if the name doesn't correspond to any
  349.  *    procedure.  Otherwise the return value is a pointer to
  350.  *    the procedure's record.
  351.  *
  352.  * Side effects:
  353.  *    None.
  354.  *
  355.  *----------------------------------------------------------------------
  356.  */
  357.  
  358. Proc *
  359. TclFindProc(iPtr, procName)
  360.     Interp *iPtr;        /* Interpreter in which to look. */
  361.     char *procName;        /* Name of desired procedure. */
  362. {
  363.     Tcl_HashEntry *hPtr;
  364.     Command *cmdPtr;
  365.  
  366.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
  367.     if (hPtr == NULL) {
  368.     return NULL;
  369.     }
  370.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  371.     if (cmdPtr->proc != InterpProc) {
  372.     return NULL;
  373.     }
  374.     return (Proc *) cmdPtr->clientData;
  375. }
  376.  
  377. /*
  378.  *----------------------------------------------------------------------
  379.  *
  380.  * TclIsProc --
  381.  *
  382.  *    Tells whether a command is a Tcl procedure or not.
  383.  *
  384.  * Results:
  385.  *    If the given command is actuall a Tcl procedure, the
  386.  *    return value is the address of the record describing
  387.  *    the procedure.  Otherwise the return value is 0.
  388.  *
  389.  * Side effects:
  390.  *    None.
  391.  *
  392.  *----------------------------------------------------------------------
  393.  */
  394.  
  395. Proc *
  396. TclIsProc(cmdPtr)
  397.     Command *cmdPtr;        /* Command to test. */
  398. {
  399.     if (cmdPtr->proc == InterpProc) {
  400.     return (Proc *) cmdPtr->clientData;
  401.     }
  402.     return (Proc *) 0;
  403. }
  404.  
  405. /*
  406.  *----------------------------------------------------------------------
  407.  *
  408.  * InterpProc --
  409.  *
  410.  *    When a Tcl procedure gets invoked, this routine gets invoked
  411.  *    to interpret the procedure.
  412.  *
  413.  * Results:
  414.  *    A standard Tcl result value, usually TCL_OK.
  415.  *
  416.  * Side effects:
  417.  *    Depends on the commands in the procedure.
  418.  *
  419.  *----------------------------------------------------------------------
  420.  */
  421.  
  422. static int
  423. InterpProc(clientData, interp, argc, argv)
  424.     ClientData clientData;    /* Record describing procedure to be
  425.                  * interpreted. */
  426.     Tcl_Interp *interp;        /* Interpreter in which procedure was
  427.                  * invoked. */
  428.     int argc;            /* Count of number of arguments to this
  429.                  * procedure. */
  430.     char **argv;        /* Argument values. */
  431. {
  432.     register Proc *procPtr = (Proc *) clientData;
  433.     register Arg *argPtr;
  434.     register Interp *iPtr = (Interp *) interp;
  435.     char **args;
  436.     CallFrame frame;
  437.     char *value, *end;
  438.     int result;
  439.  
  440.     /*
  441.      * Set up a call frame for the _new procedure invocation.
  442.      */
  443.  
  444.     iPtr = procPtr->iPtr;
  445.     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
  446.     if (iPtr->varFramePtr != NULL) {
  447.     frame.level = iPtr->varFramePtr->level + 1;
  448.     } else {
  449.     frame.level = 1;
  450.     }
  451.     frame.argc = argc;
  452.     frame.argv = argv;
  453.     frame.callerPtr = iPtr->framePtr;
  454.     frame.callerVarPtr = iPtr->varFramePtr;
  455.     iPtr->framePtr = &frame;
  456.     iPtr->varFramePtr = &frame;
  457.  
  458.     /*
  459.      * Match the actual arguments against the procedure's formal
  460.      * parameters to compute local variables.
  461.      */
  462.  
  463.     for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
  464.         argPtr != NULL;
  465.         argPtr = argPtr->nextPtr, args++, argc--) {
  466.  
  467.     /*
  468.      * Handle the special case of the last formal being "args".  When
  469.      * it occurs, assign it a list consisting of all the remaining
  470.      * actual arguments.
  471.      */
  472.  
  473.     if ((argPtr->nextPtr == NULL)
  474.         && (strcmp(argPtr->name, "args") == 0)) {
  475.         if (argc < 0) {
  476.         argc = 0;
  477.         }
  478.         value = Tcl_Merge(argc, args);
  479.         Tcl_SetVar(interp, argPtr->name, value, 0);
  480.         ckfree(value);
  481.         argc = 0;
  482.         break;
  483.     } else if (argc > 0) {
  484.         value = *args;
  485.     } else if (argPtr->defValue != NULL) {
  486.         value = argPtr->defValue;
  487.     } else {
  488.         Tcl_AppendResult(interp, "no value given for parameter \"",
  489.             argPtr->name, "\" to \"", argv[0], "\"",
  490.             (char *) NULL);
  491.         result = TCL_ERROR;
  492.         goto procDone;
  493.     }
  494.     Tcl_SetVar(interp, argPtr->name, value, 0);
  495.     }
  496.     if (argc > 0) {
  497.     Tcl_AppendResult(interp, "called \"", argv[0],
  498.         "\" with too many arguments", (char *) NULL);
  499.     result = TCL_ERROR;
  500.     goto procDone;
  501.     }
  502.  
  503.     /*
  504.      * Invoke the commands in the procedure's body.
  505.      */
  506.  
  507.     result = Tcl_Eval(interp, procPtr->command, 0, &end);
  508.     if (result == TCL_RETURN) {
  509.     result = TCL_OK;
  510.     } else if (result == TCL_ERROR) {
  511.     char msg[100];
  512.  
  513.     /*
  514.      * Record information telling where the error occurred.
  515.      */
  516.  
  517.     sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
  518.         iPtr->errorLine);
  519.     Tcl_AddErrorInfo(interp, msg);
  520.     } else if (result == TCL_BREAK) {
  521.     iPtr->result = "invoked \"break\" outside of a loop";
  522.     result = TCL_ERROR;
  523.     } else if (result == TCL_CONTINUE) {
  524.     iPtr->result = "invoked \"continue\" outside of a loop";
  525.     result = TCL_ERROR;
  526.     }
  527.  
  528.     /*
  529.      * Delete the call frame for this procedure invocation (it's
  530.      * important to remove the call frame from the interpreter
  531.      * before deleting it, so that traces invoked during the
  532.      * deletion don't see the partially-deleted frame).
  533.      */
  534.  
  535.     procDone:
  536.     iPtr->framePtr = frame.callerPtr;
  537.     iPtr->varFramePtr = frame.callerVarPtr;
  538.     TclDeleteVars(iPtr, &frame.varTable);
  539.     return result;
  540. }
  541.  
  542. /*
  543.  *----------------------------------------------------------------------
  544.  *
  545.  * ProcDeleteProc --
  546.  *
  547.  *    This procedure is invoked just before a command procedure is
  548.  *    removed from an interpreter.  Its job is to release all the
  549.  *    resources allocated to the procedure.
  550.  *
  551.  * Results:
  552.  *    None.
  553.  *
  554.  * Side effects:
  555.  *    Memory gets freed.
  556.  *
  557.  *----------------------------------------------------------------------
  558.  */
  559.  
  560. static void
  561. ProcDeleteProc(clientData)
  562.     ClientData clientData;        /* Procedure to be deleted. */
  563. {
  564.     register Proc *procPtr = (Proc *) clientData;
  565.     register Arg *argPtr;
  566.  
  567.     ckfree((char *) procPtr->command);
  568.     for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
  569.     Arg *nextPtr = argPtr->nextPtr;
  570.  
  571.     ckfree((char *) argPtr);
  572.     argPtr = nextPtr;
  573.     }
  574.     ckfree((char *) procPtr);
  575. }
  576.